home *** CD-ROM | disk | FTP | other *** search
/ BMUG PD-ROM A / PD-ROM A.iso / Programming / Programming Languages / XLISP 2.0 / XLISP Tools / Utility (UL) / SET.LSP < prev    next >
Encoding:
Lisp/Scheme  |  1988-04-07  |  2.1 KB  |  72 lines  |  [TEXT/ttxt]
  1. ;; Larry Mulcahy 1988
  2. ;; set functions
  3.  
  4. (provide 'set)
  5. (require 's-expression "s-expr")
  6.  
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8. ; intersection 
  9. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10.  
  11. (defun intersection (x y &key (test #'eql))
  12.   (if x
  13.       (let*
  14.        ((uh (car x))
  15.     (recursion
  16.       (intersection (remove uh (cdr x) :test test)
  17.                         (remove uh y :test test) :test test)))
  18.        (if (member uh y)
  19.        (cons uh recursion)
  20.        recursion))))
  21.  
  22. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  23. ; set-difference 
  24. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  25.  
  26. (defun set-difference (x y &key (test #'eql))
  27.   (if x
  28.       (let*
  29.        ((uh (car x))
  30.     (recursion
  31.           (set-difference (remove uh x :test test)
  32.                           (remove uh y :test test) :test test)))
  33.        (if (member uh y :test test)
  34.        recursion
  35.        (cons uh recursion)))))
  36.  
  37. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  38. ; union 
  39. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  40.  
  41. (defun union (s1 s2 &key (test #'eql))
  42.   (if s1
  43.       (adjoin (car s1) (union (cdr s1) s2 :test test) :test test)
  44.       s2))
  45.  
  46. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  47. ; order-preserving-intersection 
  48. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  49.  
  50. (defun order-preserving-intersection (l1 l2 &key (test #'eql))
  51.   (cond
  52.    ((or (null l1) (null l2)) nil)
  53.    ((member (car l1) l2 :test test)
  54.     (cons (car l1)
  55.       (order-preserving-intersection (cdr l1) l2)))
  56.    ((order-preserving-intersection (cdr l1) l2))))
  57.  
  58. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  59. ; order-preserving-set-difference 
  60. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  61.  
  62. (defun order-preserving-set-difference (l1 l2 &key (test #'eql))
  63.   (cond
  64.    ((null l2) l1)
  65.    ((null l1) nil)
  66.    ((member (car l1) l2 :test test)
  67.     (order-preserving-set-difference (cdr l1) l2))
  68.    ((cons (car l1)
  69.       (order-preserving-set-difference (cdr l1) l2)))))
  70.  
  71.  
  72.